home *** CD-ROM | disk | FTP | other *** search
/ Australian Personal Computer 2002 November / CD 1 / APC0211D1.ISO / workshop / prog / files / ActivePerl-5.6.1.633-MSWin32.msi / _6cf2fc52bf39089dafed2cba46f7e32a < prev    next >
Encoding:
Text File  |  2001-11-16  |  6.2 KB  |  235 lines
  1. # $Revision: 1.5 $
  2. package Archive::Zip::Archive;
  3. use File::Find ();
  4. use Archive::Zip qw(:ERROR_CODES :UTILITY_METHODS);
  5.  
  6. =head1 NAME
  7.  
  8. Archive::Zip::Tree -- methods for adding/extracting trees using Archive::Zip
  9.  
  10. =head1 SYNOPSIS
  11.  
  12.   use Archive::Zip;
  13.   use Archive::Zip::Tree;
  14.   my $zip = Archive::Zip->new();
  15.   # add all readable files and directories below . as xyz/*
  16.   $zip->addTree( '.', 'xyz' );    
  17.   # add all readable plain files below /abc as /def/*
  18.   $zip->addTree( '/abc', '/def', sub { -f && -r } );    
  19.   # add all .c files below /tmp as stuff/*
  20.   $zip->addTreeMatching( '/tmp', 'stuff', '\.c$' );
  21.   # add all .o files below /tmp as stuff/* if they aren't writable
  22.   $zip->addTreeMatching( '/tmp', 'stuff', '\.o$', sub { ! -w } );
  23.   # and write them into a file
  24.   $zip->writeToFile('xxx.zip');
  25.  
  26.   # now extract the same files into /tmpx
  27.   $zip->extractTree( 'stuff', '/tmpx' );
  28.  
  29. =head1 METHODS
  30.  
  31. =over 4
  32.  
  33. =item $zip->addTree( $root, $dest [,$pred] )
  34.  
  35. $root is the root of the tree of files and directories to be added
  36.  
  37. $dest is the name for the root in the zip file (undef or blank means to use
  38. relative pathnames)
  39.  
  40. C<$pred> is an optional subroutine reference to select files: it is passed the
  41. name of the prospective file or directory using C<$_>,
  42. and if it returns true, the file or
  43. directory will be included.  The default is to add all readable files and
  44. directories.
  45.  
  46. For instance, using
  47.  
  48.   my $pred = sub { /\.txt/ };
  49.   $zip->addTree( '.', '.', $pred );
  50.  
  51. will add all the .txt files in and below the current directory,
  52. using relative names, and making the names identical in the zipfile:
  53.  
  54.   original name           zip member name
  55.   ./xyz                   xyz
  56.   ./a/                    a/
  57.   ./a/b                   a/b
  58.  
  59. To use absolute pathnames, just pass them in:
  60.  
  61. $zip->addTree( '/a/b', '/a/b' );
  62.  
  63.   original name           zip member name
  64.   /a/                     /a/
  65.   /a/b                    /a/b
  66.  
  67. To translate relative to absolute pathnames, just pass them in:
  68.  
  69. $zip->addTree( '.', '/c/d' );
  70.  
  71.   original name           zip member name
  72.   ./xyz                   /c/d/xyz
  73.   ./a/                    /c/d/a/
  74.   ./a/b                   /c/d/a/b
  75.  
  76. To translate absolute to relative pathnames, just pass them in:
  77.  
  78. $zip->addTree( '/c/d', 'a' );
  79.  
  80.   original name           zip member name
  81.   /c/d/xyz                a/xyz
  82.   /c/d/a/                 a/a/
  83.   /c/d/a/b                a/a/b
  84.  
  85. Returns AZ_OK on success.
  86.  
  87. Note that this will not follow symbolic links to directories.
  88.  
  89. Note also that this does not check for the validity of filenames.
  90.  
  91. =back
  92.  
  93. =cut
  94.  
  95. sub addTree
  96. {
  97.     my $self = shift;
  98.     my $root = shift or return _error("root arg missing in call to addTree()");
  99.     my $dest = shift || '';
  100.     my $pred = shift || sub { -r };
  101.     $root =~ s{\\}{/}g;    # normalize backslashes in case user is misguided
  102.     $root =~ s{([^/])$}{$1/};    # append slash if necessary
  103.     $dest =~ s{([^/])$}{$1/} if $dest;    # append slash if necessary
  104.     my @files;
  105.     File::Find::find( sub { push( @files, $File::Find::name ) }, $root );
  106.     @files = grep { &$pred } @files;    # pass arg via local $_
  107.     foreach my $fileName ( @files )
  108.     {
  109.         ( my $archiveName = $fileName ) =~ s{^\Q$root}{$dest};
  110.         $archiveName =~ s{^\./}{};
  111.         next if $archiveName =~ m{^\.?/?$};    # skip current dir
  112.         my $member = ( -d $fileName )
  113.             ? $self->addDirectory( $fileName, $archiveName )
  114.             : $self->addFile( $fileName, $archiveName );
  115.         return _error( "add $fileName failed in addTree()" ) if !$member;
  116.     }
  117.     return AZ_OK;
  118. }
  119.  
  120. =over 4
  121.  
  122. =item $zip->addTreeMatching( $root, $dest, $pattern [,$pred] )
  123.  
  124. $root is the root of the tree of files and directories to be added
  125.  
  126. $dest is the name for the root in the zip file (undef means to use relative
  127. pathnames)
  128.  
  129. $pattern is a (non-anchored) regular expression for filenames to match
  130.  
  131. $pred is an optional subroutine reference to select files: it is passed the
  132. name of the prospective file or directory in C<$_>,
  133. and if it returns true, the file or
  134. directory will be included.  The default is to add all readable files and
  135. directories.
  136.  
  137. To add all files in and below the current dirctory
  138. whose names end in C<.pl>, and make them extract into a subdirectory
  139. named C<xyz>, do this:
  140.  
  141.   $zip->addTreeMatching( '.', 'xyz', '\.pl$' )
  142.  
  143. To add all I<writable> files in and below the dirctory named C</abc>
  144. whose names end in C<.pl>, and make them extract into a subdirectory
  145. named C<xyz>, do this:
  146.  
  147.   $zip->addTreeMatching( '/abc', 'xyz', '\.pl$', sub { -w } )
  148.  
  149. Returns AZ_OK on success.
  150.  
  151. Note that this will not follow symbolic links to directories.
  152.  
  153. =back
  154.  
  155. =cut
  156.  
  157. sub addTreeMatching
  158. {
  159.     my $self = shift;
  160.     my $root = shift
  161.         or return _error("root arg missing in call to addTreeMatching()");
  162.     my $dest = shift || '';
  163.     my $pattern = shift
  164.         or return _error("pattern missing in call to addTreeMatching()");
  165.     my $pred = shift || sub { -r };
  166.     my $matcher = sub { m{$pattern} && &$pred };
  167.     return $self->addTree( $root, $dest, $matcher );
  168. }
  169.  
  170. =over 4
  171.  
  172. =item $zip->extractTree( $root, $dest )
  173.  
  174. Extracts all the members below a given root. Will
  175. translate that root to a given dest pathname.
  176.  
  177. For instance,
  178.  
  179.    $zip->extractTree( '/a/', 'd/e/' );
  180.  
  181. when applied to a zip containing the files:
  182.  /a/x /a/b/c /d/e
  183.  
  184. will extract:
  185.  /a/x to d/e/x
  186.  /a/b/c to d/e/b/c
  187.  
  188. and ignore /d/e
  189.  
  190. =back 
  191.  
  192. =cut
  193.  
  194. sub extractTree
  195. {
  196.     my $self = shift();
  197.     my $root = shift();
  198.     return _error("root arg missing in call to extractTree()")
  199.         unless defined($root);
  200.     my $dest = shift || '.';
  201.     $root =~ s{\\}{/}g;    # normalize backslashes in case user is misguided
  202.     $root =~ s{([^/])$}{$1/};    # append slash if necessary
  203.     my @members = $self->membersMatching( "^$root" );
  204.     foreach my $member ( @members )
  205.     {
  206.         my $fileName = $member->fileName(); 
  207.         $fileName =~ s{$root}{$dest};
  208.         my $status = $member->extractToFileNamed( $fileName );
  209.         return $status if $status != AZ_OK;
  210.     }
  211.     return AZ_OK;
  212. }
  213.  
  214. 1;
  215. __END__
  216.  
  217. =head1 AUTHOR
  218.  
  219. Ned Konz, perl@bike-nomad.com
  220.  
  221. =head1 COPYRIGHT
  222.  
  223. Copyright (c) 2000 Ned Konz. All rights reserved.  This program is free
  224. software; you can redistribute it and/or modify it under the same terms
  225. as Perl itself.
  226.  
  227. =head1 SEE ALSO
  228.  
  229. L<Compress::Zlib>
  230. L<Archive::Zip>
  231.  
  232. =cut
  233.  
  234. # vim: ts=4 sw=4 columns=80
  235.